(require 'asdf)
(asdf:operate 'asdf:load-op :ltk)

(defpackage :ltk-user
  (:use #:ltk #:common-lisp))

(in-package :ltk-user)

(setf *debug-tk* nil)

(defun get-fortune-quote ()
  (let ((quote-vector #("Am I CONSING yet?"
			"--- I have seen the FUN ---"
			"Did I SELL OUT yet?"
			"Yow!  Are we laid back yet?"
			"Not enough people play SKEE-BALL..  They're always thinking about
 COCAINE or and ALIEN BEINGS!!"
			"TATTOOED MIDGETS are using ALFREDO in their SALAMI FACTORY!"
			"HAIR TONICS, please!!"
			"Sometime in 1993 NANCY SINATRA will lead a BLOODLESS COUP on GUAM!!"
			"I want to dress you up as TALLULAH BANKHEAD and cover you with
 VASELINE and WHEAT THINS.."
			"When you get your PH.D. will you get able to work at BURGER KING?"
			"I'm having an EMOTIONAL OUTBURST!!  But, uh, WHY is there a WAFFLE
 in my PAJAMA POCKET??"
			"Mary Tyler Moore's SEVENTH HUSBAND is wearing my DACRON TANK TOP
 in a cheap hotel in HONOLULU!"
			"I have accepted Provolone into my life!"
			"..  Like I always say -- nothing can beat the BRATWURST
 here in DUSSELDORF!!")))
    (elt quote-vector
	 (random (1- (length quote-vector))))))

(defclass fortune-gui ()
  ((frame :accessor frame)
   (quote-box :accessor quote-box)
   (button-bar :accessor button-bar)
   (new-quote-button :accessor new-quote-button)
   (previous-quote-button :accessor previous-quote-button)
   (old-quotes-stack :accessor old-quotes-stack
		     :initform nil
		     :documentation "Stack of previous quotes")))

(defmacro current-quote (gui)
  `(text (quote-box ,gui)))

(defgeneric update-fortune-quote (gui))

(defmethod update-fortune-quote ((gui fortune-gui))
  (push (current-quote gui)
	(old-quotes-stack gui))
  (setf (current-quote gui)
	(get-fortune-quote)))

(defgeneric previous-fortune-quote (gui))

(defmethod previous-fortune-quote ((gui fortune-gui))
  (setf (current-quote gui)
	(or (pop (old-quotes-stack gui))
	    (current-quote gui))))

(defmethod initialize-instance :after ((gui fortune-gui) &key)
  (setf (frame gui)
	(make-instance 'frame))
  (setf (quote-box gui)
	(make-instance 'text
		       :master (frame gui)))
  (setf (button-bar gui)
	(make-instance 'frame
		       :master (frame gui)))
  (setf (new-quote-button gui)
	(make-instance 'button
		       :master (button-bar gui)
		       :text "Next >>"
		       :command #'(lambda ()
				    (update-fortune-quote gui))))
  (setf (previous-quote-button gui)
	 (make-instance 'button
			:master (button-bar gui)
			:text "<< Back"
			:command (lambda ()
				   (previous-fortune-quote gui))))
  (wm-title *tk* "The Wit and Wisdom of Zippy the Pinhead")
  (minsize *tk* 500 70)
  (maxsize *tk* 500 70))

(defmethod run ((gui fortune-gui))
  (setf (current-quote gui)
	(get-fortune-quote))
  (pack (frame gui))
  (pack (button-bar gui)
	:expand t
	:fill 'x)
  (pack (previous-quote-button gui)
	:side :left
	:expand t
	:fill 'x)
  (pack (new-quote-button gui)
	:side :right
	:expand t
	:fill 'x)
  (pack (quote-box gui)))

(with-ltk
 (run (make-instance 'fortune-gui)))